;;  Copyright (c) Jeffrey Straszheim. All rights reserved.  The use and
;;  distribution terms for this software are covered by the Eclipse Public
;;  License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can
;;  be found in the file epl-v10.html at the root of this distribution.  By
;;  using this software in any fashion, you are agreeing to be bound by the
;;  terms of this license.  You must not remove this notice, or any other,
;;  from this software.
;;
;;  util.clj
;;
;;  A Clojure implementation of Datalog -- Utilities
;;
;;  straszheimjeffrey (gmail)
;;  Created 3 Feburary 2009


(ns clojure.datalog.util
  (:use [clojure.set :only (union)])
  (:use [clojure.contrib.seq-utils :only (separate)])
  (:use [clojure.contrib.except :only (throw-if)]))


;;; Bindings and logic vars.  A binding in a hash of logic vars to
;;; bound values.  Logic vars are any symbol prefixed with a \?.

(defn is-var?
  "Is this a logic variable: e.g. a symbol prefixed with a ?"
  [sym]
  (when (symbol? sym)
    (= \? (first (name sym)))))

(defn map-values
  "Like map, but works over the values of a hash map"
  [f hash]
  (let [key-vals (map (fn [[key val]] [key (f val)]) hash)]
    (if key-vals
      (apply conj (empty hash) key-vals)
      hash)))


;;; Fixed point

(defn fixed-point
  "Repeatedly execute action on data until the data does not change.
   If max iterations occur, an exception is thrown.

   data - The initial data
   action - a function that takes a data object and returns the new one
   max - The max number of expected iterations.  Use -2 to be unbounded
   transform (optional) - A function used for custom comparison.  The
     loop terminates when (transform old-data) equals (transform new-data)."
  ([data action max]
     (fixed-point data action max identity))
  ([data action max transform]
     (loop [data data
            count (and max (inc max))]
       (throw-if (= count 0) "Fixed point overflow")
       (let [old (transform data)
             new (action data)]
         (if (= old (transform new))
           new
           (recur new (and count (dec count))))))))


;;; Directed Graph Algorithms

;; To maintain their identity, graph nodes are identified by keys.  A
;; single node can be named by mulitple keys, and a single key can
;; identify multiple nodes.

(defstruct directed-graph
  :nodes          ; The nodes of the graph
  :get-keys       ; Given a node, provide the keys (a collection) that
                  ; name it
  :get-neighbors) ; Given a node, provide the keys (a collection) of
                  ; nodes it links to

;; Many of these functions need to build a lookup hash to efficiently
;; process the graph.  In most cases, you can pre-comptue the lookup
;; and pass it in.1

(defn make-lookup
  "Given a graph, returns a lookup table that maps a key to a set of
   nodes"
  [{:keys [nodes get-keys]}]
  (if-let [result (apply merge-with union (for [node nodes
                                                key (get-keys node)]
                                            {key #{node}}))]
    result
    {}))

(defn reverse-graph
  "Given a graph, return one with the edges reversed."
  [{:keys (nodes get-keys get-neighbors)}]
  (struct-map directed-graph
    :nodes nodes
    :get-keys get-neighbors
    :get-neighbors get-keys))

(defn get-adjacent-nodes
  "From a graph and a node, return a set of linked nodes"
  ([graph node]
     (get-adjacent-nodes graph (make-lookup graph) node))
  ([{:keys [nodes get-neighbors]} lookup node]
     (let [edges (get-neighbors node)]
       (reduce union #{} (map lookup edges)))))

(defn- post-order-visit
  [graph lookup state node]
  (let [visit (fn visit [[visited col :as state] node]
                (if (visited node)
                  state
                  (let [[visited col] (reduce visit
                                              [(conj visited node) col]
                                              (get-adjacent-nodes graph lookup node))]
                    [visited (conj col node)])))]
    (visit state node)))

(defn post-ordered-depth-first-walk
  "Walk a graph depth first and conj the nodes to a provided
   collection post order."
  [graph lookup col]
  (let [[_ col] (reduce (partial post-order-visit graph lookup)
                        [#{} col]
                        (:nodes graph))]
    col))
    

;;; Find strongly connected components

(defn scc
  "Find strongly connected components of a graph. Returs a collection
   of sets of nodes."
  [graph lookup]
  (let [dfw (post-ordered-depth-first-walk graph (make-lookup graph) ())
        rev (reverse-graph graph)
        rev-l (make-lookup rev)
        step (fn [visited stack results]
               (if (empty? stack)
                 results
                 (let [[new-visited new-col] (post-order-visit rev rev-l [visited ()] (first stack))
                       new-results (conj results (set new-col))
                       new-stack (remove new-visited stack)]
                   (recur new-visited new-stack new-results))))]
  (step #{} dfw [])))

(defn partition-into-recursive-sets
  "Given a graph, return a collection of sets where all mutually
   recursive nodes are assigned to the same set.  Non-recursive nodes
   are excluded from the results."
  ([graph] (partition-into-recursive-sets graph (make-lookup graph)))
  ([graph lookup]
     (let [recursive? (fn [nodes]
                        (or (> (count nodes) 1)
                            ((get-adjacent-nodes graph lookup (first nodes)) (first nodes))))]
       (filter recursive? (scc graph lookup)))))
  

;; Graph tests
(comment

  (def node-1 [[:fred :mary] [:fred :sally :joan]])
  (def node-2 [[:mary] [:mary]])
  (def node-3 [[:sally] [:joan]])
  (def node-4 [[:frank] [:eliot]])

  (def graph (struct-map directed-graph
                 :nodes #{
                          node-1
                          node-2
                          node-3
                          node-4
                          [[:peggy] [:sue]]
                          [[:sue] [:frank :lilly]]
                          [[:lilly] [:peggy :frank]]
                          [[:sally :joan] []]
                          [[:joan] [:bob]]
                          [[:bob :eliot] [:frank]]
                          [[:joe] [:joe]]}
                 :get-keys first
                 :get-neighbors last))

  (def rev (reverse-graph graph))

  (make-lookup graph)

  (get-adjacent-nodes graph node-1)
  (get-adjacent-nodes graph node-2)

  (map count (scc graph (make-lookup graph)))
  (map count (partition-into-recursive-sets graph (make-lookup graph)))
)


;;; Build work plans

(defn build-dependency-levels
  "Using a fixed point computation, assign a dependency level to each
   item in a graph.  The following functions must be provided:

   level - given a node return its level
   new-node - given a node and its dependent nodes, return a new node
     with a new level"
  [graph level new-node]
  (let [max (count (:nodes graph))
        transform (fn [{:keys [nodes]}] (map level nodes))
        each (fn [graph lookup node]
               (new-node node (get-adjacent-nodes graph lookup node)))
        action (fn [{:keys [nodes get-keys get-neighbors] :as graph}]
                 (let [lookup (make-lookup graph)
                       new-nodes (set (map (partial each graph lookup) nodes))]
                   (struct directed-graph new-nodes get-keys get-neighbors)))]
    (fixed-point graph action max transform)))

(defn build-dependency-array
  "Given a set of items with computed priority levels, arange them
   sequentially in a vector, with those of priority 0 at index 0,
   those at priority 1 index 1, and so on.  The following functions
   must be provided:

   level - when passed an element, returns its priority level."
  [data level]
  (let [max-p (apply max 0 (map level data))
        acc (vec (replicate (inc max-p) #{}))
        each (fn [acc el]
               (let [l (level el)]
                 (assoc acc l (conj (nth acc l) el))))]
    (reduce each acc data)))


;;; Preduce -- A parallel reduce over hashes
  
(defn preduce
  "Similar to merge-with, but the contents of each key are merged in
   parallel using f.

   f - a function of 2 arguments.
   data - a collection of hashes."
  [f data]
  (let [data-1 (map (fn [h] (map-values #(list %) h)) data)
        merged (doall (apply merge-with concat data-1))
        ; Groups w/ multiple elements are identified for parallel processing
        [complex simple] (separate (fn [[key vals]] (> (count vals) 1)) merged)
        fold-group (fn [[key vals]] {key (reduce f vals)})
        fix-single (fn [[key [val]]] [key val])]
    (apply merge (concat (pmap fold-group merged) (map fix-single simple)))))
  

 	
 	
;; End of file
